home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / vm / vm-menu.el.z / vm-menu.el
Encoding:
Text File  |  1998-05-21  |  46.8 KB  |  1,418 lines
  1. ;;; Menu related functions and commands
  2. ;;; Copyright (C) 1995, 1997 Kyle E. Jones
  3. ;;;
  4. ;;; Folders menu derived from
  5. ;;;     vm-folder-menu.el
  6. ;;;     v1.10; 03-May-1994
  7. ;;;     Copyright (C) 1994 Heiko Muenkel
  8. ;;;     email: muenkel@tnt.uni-hannover.de
  9. ;;;  Used with permission and my thanks.
  10. ;;;  Changed 18-May-1995, Kyle Jones
  11. ;;;     Cosmetic string changes, changed some variable names
  12. ;;;     and interfaced it with FSF Emacs via easymenu.el.
  13. ;;;   
  14. ;;; Tree menu code is essentially tree-menu.el with renamed functions
  15. ;;;     tree-menu.el
  16. ;;;     v1.20; 10-May-1994
  17. ;;;     Copyright (C) 1994 Heiko Muenkel
  18. ;;;     email: muenkel@tnt.uni-hannover.de
  19. ;;;
  20. ;;;  Changed 18-May-1995, Kyle Jones
  21. ;;;    Removed the need for the utils.el package and references thereto.
  22. ;;;    Changed file-truename calls to tree-menu-file-truename so
  23. ;;;    the calls could be made compatible with FSF Emacs 19's
  24. ;;;    file-truename function.
  25. ;;;  Changed 30-May-1995, Kyle Jones
  26. ;;;    Renamed functions: tree- -> vm-menu-hm-tree.
  27. ;;;  Changed 5-July-1995, Kyle Jones
  28. ;;;    Removed the need for -A in ls flags.
  29. ;;;    Some systems' ls don't support -A.
  30. ;;;
  31. ;;; This program is free software; you can redistribute it and/or modify
  32. ;;; it under the terms of the GNU General Public License as published by
  33. ;;; the Free Software Foundation; either version 1, or (at your option)
  34. ;;; any later version.
  35. ;;;
  36. ;;; This program is distributed in the hope that it will be useful,
  37. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  38. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  39. ;;; GNU General Public License for more details.
  40. ;;;
  41. ;;; You should have received a copy of the GNU General Public License
  42. ;;; along with this program; if not, write to the Free Software
  43. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  44.  
  45. (provide 'vm-menu)
  46.  
  47. ;; copied from vm-vars.el because vm-xemacs-p, vm-xemacs-mule-p, 
  48. ;; vm-fsfemacs-mule-p, and vm-fsfemacs-p are needed below at load time
  49. ;; and vm-note-emacs-version may not be autoloadable.
  50. (or (fboundp 'vm-note-emacs-version)
  51.     (defun vm-note-emacs-version ()
  52.       (setq vm-xemacs-p (string-match "XEmacs" emacs-version)
  53.         vm-xemacs-mule-p (and vm-xemacs-p (featurep 'mule)
  54.                   ;; paranoia
  55.                   (fboundp 'set-file-coding-system))
  56.         vm-fsfemacs-p (not vm-xemacs-p)
  57.         vm-fsfemacs-mule-p (and (not vm-xemacs-mule-p) (featurep 'mule)
  58.                     (fboundp 'set-buffer-file-coding-system)))))
  59.  
  60. ;; make sure the emacs/xemacs version variables are set, as they
  61. ;; are needed below at load time.
  62. (vm-note-emacs-version)
  63.  
  64. (defun vm-menu-fsfemacs-menus-p ()
  65.   (and vm-fsfemacs-p
  66.        (fboundp 'menu-bar-mode)))
  67.  
  68. (defun vm-menu-xemacs-menus-p ()
  69.   (and vm-xemacs-p
  70.        (fboundp 'set-buffer-menubar)))
  71.  
  72. (defun vm-fsfemacs-p ()
  73.   (not (string-match "XEmacs\\|Lucid" emacs-version)))
  74.  
  75. (defvar vm-menu-folders-menu 
  76.   '("Manipulate Folders"
  77.     ["Make Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory])
  78.   "VM folder menu list.")
  79.  
  80. (defconst vm-menu-folder-menu
  81.   (list
  82.    "Folder"
  83.    (if vm-fsfemacs-p
  84.        ["Manipulate Folders" ignore (ignore)]
  85.      vm-menu-folders-menu)
  86.    "---"
  87.    ["Display Summary" vm-summarize t]
  88.    ["Toggle Threading" vm-toggle-threads-display t]
  89.    "---"
  90.    ["Get New Mail" vm-get-new-mail (vm-menu-can-get-new-mail-p)]
  91.    "---"
  92.    ["Search" vm-isearch-forward vm-message-list]
  93.    "---"
  94.    ["Auto-Archive" vm-auto-archive-messages vm-message-list]
  95.    ["Expunge" vm-expunge-folder vm-message-list]
  96.    ["Expunge POP Messages" vm-expunge-pop-messages t]
  97.    "---"
  98.    ["Visit Folder" vm-visit-folder t]
  99.    ["Revert Folder (back to disk version)" revert-buffer (vm-menu-can-revert-p)]
  100.    ["Recover Folder (from auto-save file)" recover-file (vm-menu-can-recover-p)]
  101.    ["Save" vm-save-folder (vm-menu-can-save-p)]
  102.    ["Save As..." vm-write-file t]
  103.    ["Quit" vm-quit-no-change t]
  104.    ["Save & Quit" vm-quit t]
  105.    "---"
  106.    "---"
  107.    ;; special string that marks the tail of this menu for
  108.    ;; vm-menu-install-visited-folders-menu.
  109.    "-------"
  110.    ))
  111.  
  112. (defconst vm-menu-dispose-menu
  113.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  114.            (list "Dispose"
  115.              "Dispose"
  116.              "---"
  117.              "---")
  118.          (list "Dispose"))))
  119.     (append
  120.      title
  121.      (list
  122.       ["Reply to Author" vm-reply vm-message-list]
  123.       ["Reply to All" vm-followup vm-message-list]
  124.       ["Reply to Author (citing original)" vm-reply-include-text vm-message-list]
  125.       ["Reply to All (citing original)" vm-followup-include-text vm-message-list]
  126.       ["Forward" vm-forward-message vm-message-list]
  127.       ["Resend" vm-resend-message vm-message-list]
  128.       ["Retry Bounce" vm-resend-bounced-message vm-message-list]
  129.       "---"
  130.       ["File" vm-save-message vm-message-list]
  131.       ["Delete" vm-delete-message vm-message-list]
  132.       ["Undelete"    vm-undelete-message vm-message-list]
  133.       ["Kill Current Subject" vm-kill-subject vm-message-list]
  134.       ["Mark Unread" vm-unread-message vm-message-list]
  135.       ["Edit" vm-edit-message vm-message-list]
  136.       ["Print" vm-print-message vm-message-list]
  137.       ["Pipe to Command" vm-pipe-message-to-command vm-message-list]
  138.       "---"
  139.       ["Burst Message as Digest" (vm-burst-digest "guess") vm-message-list]
  140.       ["Decode MIME" vm-decode-mime-message (vm-menu-can-decode-mime-p)]
  141.       ))))
  142.  
  143. (defconst vm-menu-motion-menu
  144.   '("Motion"
  145.     ["Page Up" vm-scroll-backward vm-message-list]
  146.     ["Page Down" vm-scroll-forward vm-message-list]
  147.     "----"
  148.     ["Beginning" vm-beginning-of-message vm-message-list]
  149.     ["End" vm-end-of-message vm-message-list]
  150.     "----"
  151.     ["Expose/Hide Headers" vm-expose-hidden-headers vm-message-list]
  152.     "----"
  153.     "----"
  154.     ["Next Message" vm-next-message t]
  155.     ["Previous Message"    vm-previous-message t]
  156.     "---"
  157.     ["Next, Same Subject" vm-next-message-same-subject t]
  158.     ["Previous, Same Subject" vm-previous-message-same-subject t]
  159.     "---"
  160.     ["Next Unread" vm-next-unread-message t]
  161.     ["Previous Unread" vm-previous-unread-message t]
  162.     "---"
  163.     ["Next Message (no skip)" vm-next-message-no-skip t]
  164.     ["Previous Message (no skip)" vm-previous-message-no-skip t]
  165.     "---"
  166.     ["Go to Last Seen Message" vm-goto-message-last-seen t]
  167.     ["Go to Message" vm-goto-message t]
  168.     ["Go to Parent Message" vm-goto-parent-message t]
  169.     ))
  170.  
  171. (defconst vm-menu-virtual-menu
  172.   '("Virtual"
  173.     ["Visit Virtual Folder" vm-visit-virtual-folder t]
  174.     ["Create Virtual Folder" vm-create-virtual-folder t]
  175.     ["Apply Virtual Folder" vm-apply-virtual-folder t]
  176.     "---"
  177.     "---"
  178.     ;; special string that marks the tail of this menu for
  179.     ;; vm-menu-install-known-virtual-folders-menu.
  180.     "-------"
  181.     ))
  182.  
  183. (defconst vm-menu-send-menu
  184.   '("Send"
  185.     ["Compose" vm-mail t]
  186.     ["Continue Composing" vm-continue-composing-message vm-message-list]
  187.     ["Reply to Author" vm-reply vm-message-list]
  188.     ["Reply to All" vm-followup vm-message-list]
  189.     ["Reply to Author (citing original)" vm-reply-include-text vm-message-list]
  190.     ["Reply to All (citing original)" vm-followup-include-text vm-message-list]
  191.     ["Forward Message" vm-forward-message vm-message-list]
  192.     ["Resend Message" vm-resend-message vm-message-list]
  193.     ["Retry Bounced Message" vm-resend-bounced-message vm-message-list]
  194.     ["Send Digest (RFC934)" vm-send-rfc934-digest vm-message-list]
  195.     ["Send Digest (RFC1153)" vm-send-rfc1153-digest vm-message-list]
  196.     ["Send MIME Digest" vm-send-mime-digest vm-message-list]
  197.     ))
  198.  
  199. (defconst vm-menu-mark-menu
  200.   '("Mark"
  201.     ["Next Command Uses Marks..." vm-next-command-uses-marks
  202.      :active vm-message-list
  203.      :style radio
  204.      :selected (eq last-command 'vm-next-command-uses-marks)]
  205.     "----"
  206.     ["Mark" vm-mark-message vm-message-list]
  207.     ["Unmark" vm-unmark-message vm-message-list]
  208.     ["Mark All" vm-mark-all-messages vm-message-list]
  209.     ["Clear All Marks" vm-clear-all-marks vm-message-list]
  210.     ["Mark Region in Summary" vm-mark-summary-region vm-message-list]
  211.     ["Unmark Region in Summary" vm-unmark-summary-region vm-message-list]
  212.     "----"
  213.     ["Mark Same Subject" vm-mark-messages-same-subject vm-message-list]
  214.     ["Unmark Same Subject" vm-unmark-messages-same-subject vm-message-list]
  215.     ["Mark Same Author" vm-mark-messages-same-author vm-message-list]
  216.     ["Unmark Same Author" vm-unmark-messages-same-author vm-message-list]
  217.     ["Mark Messages Matching..." vm-mark-matching-messages vm-message-list]
  218.     ["Unmark Messages Matching..." vm-unmark-matching-messages vm-message-list]
  219.     ["Mark Thread Subtree" vm-mark-thread-subtree vm-message-list]
  220.     ["Unmark Thread Subtree" vm-unmark-thread-subtree vm-message-list]
  221.     ))
  222.  
  223. (defconst vm-menu-label-menu
  224.   '("Label"
  225.     ["Add Label" vm-add-message-labels vm-message-list]
  226.     ["Remove Label" vm-delete-message-labels vm-message-list]
  227.     ))
  228.  
  229. (defconst vm-menu-sort-menu
  230.   '("Sort"
  231.     ["By Multiple Fields..." vm-sort-messages vm-message-list]
  232.     "---"
  233.     ["By Date" (vm-sort-messages "date") vm-message-list]
  234.     ["By Subject" (vm-sort-messages "subject") vm-message-list]
  235.     ["By Author" (vm-sort-messages "author") vm-message-list]
  236.     ["By Recipients" (vm-sort-messages "recipients") vm-message-list]
  237.     ["By Lines" (vm-sort-messages "line-count") vm-message-list]
  238.     ["By Bytes" (vm-sort-messages "byte-count") vm-message-list]
  239.     "---"
  240.     ["By Date (backward)" (vm-sort-messages "reversed-date") vm-message-list]
  241.     ["By Subject (backward)" (vm-sort-messages "reversed-subject") vm-message-list]
  242.     ["By Author (backward)" (vm-sort-messages "reversed-author") vm-message-list]
  243.     ["By Recipients (backward)" (vm-sort-messages "reversed-recipients") vm-message-list]
  244.     ["By Lines (backwards)" (vm-sort-messages "reversed-line-count") vm-message-list]
  245.     ["By Bytes (backward)" (vm-sort-messages "reversed-byte-count") vm-message-list]
  246.     "---"
  247.     ["Toggle Threading" vm-toggle-threads-display t]
  248.     "---"
  249.     ["Revert to Physical Order" (vm-sort-messages "physical-order" t) vm-message-list]
  250.     ))
  251.  
  252. (defconst vm-menu-help-menu
  253.   '("Help!"
  254.     ["What Now?" vm-help t]
  255.     ["Describe Mode" describe-mode t]
  256.     ["Revert Folder (back to disk version)" revert-buffer (vm-menu-can-revert-p)]
  257.     ["Recover Folder (from auto-save file)" recover-file (vm-menu-can-recover-p)]
  258.     "---"
  259.     ["Save Folder & Quit" vm-quit t]
  260.     ["Quit Without Saving" vm-quit-no-change t]
  261.     ))
  262.  
  263. (defconst vm-menu-undo-menu
  264.   ["Undo" vm-undo (vm-menu-can-undo-p)]
  265.   )
  266.  
  267. (defconst vm-menu-emacs-button
  268.   ["XEmacs" vm-menu-toggle-menubar t]
  269.   )
  270.  
  271. (defconst vm-menu-vm-button
  272.   ["VM" vm-menu-toggle-menubar t]
  273.   )
  274.  
  275. (defconst vm-menu-mail-menu
  276.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  277.            (list "Mail Commands"
  278.              "Mail Commands"
  279.              "---"
  280.              "---")
  281.          (list "Mail Commands"))))
  282.     (append
  283.      title
  284.      (list ["Send and Exit" vm-mail-send-and-exit (vm-menu-can-send-mail-p)]
  285.        ["Send, Keep Composing" vm-mail-send (vm-menu-can-send-mail-p)]
  286.        ["Cancel" kill-buffer t]
  287.        "----"
  288.        ["Yank Original" vm-menu-yank-original vm-reply-list]
  289.        "----"
  290.        (append
  291.         (if (vm-menu-fsfemacs-menus-p)
  292.         (list "Send Using MIME..."
  293.               "Send Using MIME..."
  294.               "---"
  295.               "---")
  296.           (list "Send Using MIME..."))
  297.         (list
  298.          ["Use MIME"
  299.           (set (make-local-variable 'vm-send-using-mime) t)
  300.           :active t
  301.           :style radio
  302.           :selected vm-send-using-mime]
  303.          ["Don't use MIME"
  304.           (set (make-local-variable 'vm-send-using-mime) nil)
  305.           :active t
  306.           :style radio
  307.           :selected (not vm-send-using-mime)]))
  308.        (append
  309.         (if (vm-menu-fsfemacs-menus-p)
  310.         (list "Fragment Messages Larger Than ..."
  311.               "Fragment Messages Larger Than ..."
  312.               "---"
  313.               "---")
  314.           (list "Fragment Messages Larger Than ..."))
  315.         (list ["Infinity, i.e., don't fragment"
  316.            (set (make-local-variable 'vm-mime-max-message-size) nil)
  317.            :active vm-send-using-mime
  318.            :style radio
  319.            :selected (eq vm-mime-max-message-size nil)]
  320.           ["50000 bytes"
  321.            (set (make-local-variable 'vm-mime-max-message-size)
  322.             50000)
  323.            :active vm-send-using-mime
  324.            :style radio
  325.            :selected (eq vm-mime-max-message-size 50000)]
  326.           ["100000 bytes"
  327.            (set (make-local-variable 'vm-mime-max-message-size)
  328.             100000)
  329.            :active vm-send-using-mime
  330.            :style radio
  331.            :selected (eq vm-mime-max-message-size 100000)]
  332.           ["200000 bytes"
  333.            (set (make-local-variable 'vm-mime-max-message-size)
  334.             200000)
  335.            :active vm-send-using-mime
  336.            :style radio
  337.            :selected (eq vm-mime-max-message-size 200000)]
  338.           ["500000 bytes"
  339.            (set (make-local-variable 'vm-mime-max-message-size)
  340.             500000)
  341.            :active vm-send-using-mime
  342.            :style radio
  343.            :selected (eq vm-mime-max-message-size 500000)]
  344.           ["1000000 bytes"
  345.            (set (make-local-variable 'vm-mime-max-message-size)
  346.             1000000)
  347.            :active vm-send-using-mime
  348.            :style radio
  349.            :selected (eq vm-mime-max-message-size 1000000)]
  350.           ["2000000 bytes"
  351.            (set (make-local-variable 'vm-mime-max-message-size)
  352.             2000000)
  353.            :active vm-send-using-mime
  354.            :style radio
  355.            :selected (eq vm-mime-max-message-size 2000000)]))
  356.        (append
  357.         (if (vm-menu-fsfemacs-menus-p)
  358.         (list "Encode 8-bit Characters Using ..."
  359.               "Encode 8-bit Characters Using ..."
  360.               "---"
  361.               "---")
  362.           (list "Encode 8-bit Characters Using ..."))
  363.         (list
  364.          ["Nothing, i.e., send unencoded"
  365.           (set (make-local-variable 'vm-mime-8bit-text-transfer-encoding)
  366.            '8bit)
  367.           :active vm-send-using-mime
  368.           :style radio
  369.           :selected (eq vm-mime-8bit-text-transfer-encoding '8bit)]
  370.          ["Quoted-Printable"
  371.           (set (make-local-variable 'vm-mime-8bit-text-transfer-encoding)
  372.            'quoted-printable)
  373.           :active vm-send-using-mime
  374.           :style radio
  375.           :selected (eq vm-mime-8bit-text-transfer-encoding
  376.                 'quoted-printable)]
  377.          ["BASE64"
  378.           (set (make-local-variable 'vm-mime-8bit-text-transfer-encoding)
  379.            'base64)
  380.           :active vm-send-using-mime
  381.           :style radio
  382.           :selected (eq vm-mime-8bit-text-transfer-encoding 'base64)]))
  383.        "----"
  384.        ["Attach File..."    vm-mime-attach-file vm-send-using-mime]
  385. ;;       ["Attach MIME Message..." vm-mime-attach-mime-file
  386. ;;        vm-send-using-mime]
  387.        ["Encode MIME, But Don't Send" vm-mime-encode-composition
  388.         (and vm-send-using-mime
  389.          (null (vm-mail-mode-get-header-contents "MIME-Version:")))]
  390.        ["Preview MIME Before Sending" vm-mime-preview-composition
  391.         vm-send-using-mime]
  392.        ))))
  393.  
  394. (defconst vm-menu-mime-dispose-menu
  395.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  396.            (list "Take Action on MIME body ..."
  397.              "Take Action on MIME body ..."
  398.              "---"
  399.              "---")
  400.          (list "Take Action on MIME body ..."))))
  401.     (append
  402.      title
  403.      (list ["Display as US-ASCII Text"
  404.         (vm-mime-run-display-function-at-point
  405.          'vm-mime-display-body-as-text) t]
  406.        ["Display using External Viewer"
  407.         (vm-mime-run-display-function-at-point
  408.          'vm-mime-display-body-using-external-viewer) t]
  409.        "---"
  410.        ["Save to File" (vm-mime-run-display-function-at-point
  411.                 'vm-mime-send-body-to-file) t]
  412.        ["Send to Printer" (vm-mime-run-display-function-at-point
  413.                    'vm-mime-send-body-to-printer) t]
  414.        ["Feed to Shell Pipeline (display output)"
  415.         (vm-mime-run-display-function-at-point
  416.          'vm-mime-pipe-body-to-queried-command) t]
  417.        ["Feed to Shell Pipeline (discard output)"
  418.         (vm-mime-run-display-function-at-point
  419.          'vm-mime-pipe-body-to-queried-command-discard-output) t]))))
  420.  
  421. (defconst vm-menu-url-browser-menu
  422.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  423.            (list "Send URL to ..."
  424.              "Send URL to ..."
  425.              "---"
  426.              "---")
  427.          (list "Send URL to ...")))
  428.     (w3 (cond ((fboundp 'w3-fetch-other-frame)
  429.            'w3-fetch-other-frame)
  430.           ((fboundp 'w3-fetch)
  431.            'w3-fetch)
  432.           (t 'w3-fetch-other-frame))))
  433.     (append
  434.      title
  435.      (list (vector "Emacs W3"
  436.            (list 'vm-mouse-send-url-at-position
  437.              '(point)
  438.              (list 'quote w3))
  439.            (list 'fboundp (list 'quote w3)))
  440.        ["Mosaic"
  441.         (vm-mouse-send-url-at-position (point)
  442.                        'vm-mouse-send-url-to-mosaic)
  443.         t]
  444.        ["Netscape"
  445.         (vm-mouse-send-url-at-position (point)
  446.                        'vm-mouse-send-url-to-netscape)
  447.         t]))))
  448.  
  449. (defconst vm-menu-mailto-url-browser-menu
  450.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  451.            (list "Send Mail using ..."
  452.              "Send Mail using ..."
  453.              "---"
  454.              "---")
  455.          (list "Send Mail using ..."))))
  456.     (append
  457.      title
  458.      (list ["VM" (vm-mouse-send-url-at-position (point) 'ignore) t]))))
  459.  
  460. (defconst vm-menu-subject-menu
  461.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  462.            (list "Take Action on Subject..."
  463.              "Take Action on Subject..."
  464.              "---"
  465.              "---")
  466.          (list "Take Action on Subject..."))))
  467.     (append
  468.      title
  469.      (list
  470.       ["Kill Subject" vm-kill-subject vm-message-list]
  471.       ["Next Message, Same Subject" vm-next-message-same-subject
  472.        vm-message-list]
  473.       ["Previous Message, Same Subject" vm-previous-message-same-subject
  474.        vm-message-list]
  475.       ["Mark Messages, Same Subject" vm-mark-messages-same-subject
  476.        vm-message-list]
  477.       ["Unmark Messages, Same Subject" vm-unmark-messages-same-subject
  478.        vm-message-list]
  479.       ["Virtual Folder, Matching Subject" vm-menu-create-subject-virtual-folder
  480.        vm-message-list]
  481.       ))))
  482.  
  483. (defconst vm-menu-author-menu
  484.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  485.            (list "Take Action on Author..."
  486.              "Take Action on Author..."
  487.              "---"
  488.              "---")
  489.          (list "Take Action on Author..."))))
  490.     (append
  491.      title
  492.      (list
  493.       ["Mark Messages, Same Author" vm-mark-messages-same-author
  494.        vm-message-list]
  495.       ["Unmark Messages, Same Author" vm-unmark-messages-same-author
  496.        vm-message-list]
  497.       ["Virtual Folder, Matching Author" vm-menu-create-author-virtual-folder
  498.        vm-message-list]
  499.       ))))
  500.  
  501. (defconst vm-menu-content-disposition-menu
  502.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  503.            (list "Set Content Disposition"
  504.              "Set Content Disposition"
  505.              "---"
  506.              "---")
  507.          (list "Set Content Disposition"))))
  508.     (append
  509.      title
  510.      (list ["Unspecified"
  511.         (vm-mime-set-attachment-disposition-at-point 'unspecified)
  512.         :active vm-send-using-mime
  513.         :style radio
  514.         :selected (eq (vm-mime-attachment-disposition-at-point)
  515.               'unspecified)]
  516.        ["Inline"
  517.         (vm-mime-set-attachment-disposition-at-point 'inline)
  518.         :active vm-send-using-mime
  519.         :style radio
  520.         :selected (eq (vm-mime-attachment-disposition-at-point) 'inline)]
  521.        ["Attachment"
  522.         (vm-mime-set-attachment-disposition-at-point 'attachment)
  523.         :active vm-send-using-mime
  524.         :style radio
  525.         :selected (eq (vm-mime-attachment-disposition-at-point)
  526.               'attachment)]))))
  527.  
  528. (defvar vm-menu-vm-menubar nil)
  529.  
  530. (defconst vm-menu-vm-menu
  531.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  532.            (list "VM"
  533.              "VM"
  534.              "---"
  535.              "---")
  536.          (list "VM"))))
  537.     (append title
  538.         (list vm-menu-folder-menu
  539.           vm-menu-motion-menu
  540.           vm-menu-send-menu
  541.           vm-menu-mark-menu
  542.           vm-menu-label-menu
  543.           vm-menu-sort-menu
  544.           vm-menu-virtual-menu
  545. ;;          vm-menu-undo-menu
  546.           vm-menu-dispose-menu
  547.           "---"
  548.           "---"
  549.           vm-menu-help-menu))))
  550.  
  551. (defvar vm-mode-menu-map nil)
  552.  
  553. (defun vm-menu-run-command (command &rest args)
  554.   "Run COMMAND almost interactively, with ARGS.
  555. call-interactive can't be used unfortunately, but this-command is
  556. set to the command name so that window configuration will be done."
  557.   (setq this-command command)
  558.   (apply command args))
  559.  
  560. (defun vm-menu-can-revert-p ()
  561.   (condition-case nil
  562.       (save-excursion
  563.     (vm-select-folder-buffer)
  564.     (and (buffer-modified-p) buffer-file-name))
  565.     (error nil)))
  566.  
  567. (defun vm-menu-can-recover-p ()
  568.   (condition-case nil
  569.       (save-excursion
  570.     (vm-select-folder-buffer)
  571.     (and buffer-file-name
  572.          buffer-auto-save-file-name
  573.          (file-newer-than-file-p
  574.           buffer-auto-save-file-name
  575.           buffer-file-name)))
  576.     (error nil)))
  577.  
  578. (defun vm-menu-can-save-p ()
  579.   (condition-case nil
  580.       (save-excursion
  581.     (vm-select-folder-buffer)
  582.     (or (eq major-mode 'vm-virtual-mode)
  583.         (buffer-modified-p)))
  584.     (error nil)))
  585.  
  586. (defun vm-menu-can-get-new-mail-p ()
  587.   (condition-case nil
  588.       (save-excursion
  589.     (vm-select-folder-buffer)
  590.     (or (eq major-mode 'vm-virtual-mode)
  591.         (and (not vm-block-new-mail) (not vm-folder-read-only))))
  592.     (error nil)))
  593.  
  594. (defun vm-menu-can-undo-p ()
  595.   (condition-case nil
  596.       (save-excursion
  597.     (vm-select-folder-buffer)
  598.     vm-undo-record-list)
  599.     (error nil)))
  600.  
  601. (defun vm-menu-can-decode-mime-p ()
  602.   (condition-case nil
  603.       (save-excursion
  604.     (vm-select-folder-buffer)
  605.     (and vm-display-using-mime
  606.          vm-message-pointer
  607.          vm-presentation-buffer
  608. ;;         (not vm-mime-decoded)
  609.          (not (vm-mime-plain-message-p (car vm-message-pointer)))))
  610.     (error nil)))
  611.  
  612. (defun vm-menu-yank-original ()
  613.   (interactive)
  614.   (save-excursion
  615.     (let ((mlist vm-reply-list))
  616.       (while mlist
  617.     (vm-yank-message (car mlist))
  618.     (goto-char (point-max))
  619.     (setq mlist (cdr mlist))))))
  620.  
  621. (defun vm-menu-can-send-mail-p ()
  622.   (save-match-data
  623.     (catch 'done
  624.       (let ((headers '("to" "cc" "bcc" "resent-to" "resent-cc" "resent-bcc"))
  625.         h)
  626.     (while headers
  627.       (setq h (vm-mail-mode-get-header-contents (car headers)))
  628.       (and (stringp h) (string-match "[^ \t\n,]" h)
  629.            (throw 'done t))
  630.       (setq headers (cdr headers)))
  631.     nil ))))
  632.  
  633. (defun vm-menu-create-subject-virtual-folder ()
  634.   (interactive)
  635.   (vm-select-folder-buffer)
  636.   (setq this-command 'vm-create-virtual-folder)
  637.   (vm-create-virtual-folder 'subject (regexp-quote
  638.                       (vm-so-sortable-subject
  639.                        (car vm-message-pointer)))))
  640.  
  641. (defun vm-menu-create-author-virtual-folder ()
  642.   (interactive)
  643.   (vm-select-folder-buffer)
  644.   (setq this-command 'vm-create-virtual-folder)
  645.   (vm-create-virtual-folder 'author (regexp-quote
  646.                      (vm-su-from (car vm-message-pointer)))))
  647.  
  648. (defun vm-menu-xemacs-global-menubar ()
  649.   (save-excursion
  650.     (set-buffer (get-buffer-create "*scratch*"))
  651.     current-menubar))
  652.  
  653. (defun vm-menu-fsfemacs-global-menubar ()
  654.   (lookup-key (current-global-map) [menu-bar]))
  655.  
  656. (defun vm-menu-initialize-vm-mode-menu-map ()
  657.   (if (null vm-mode-menu-map)
  658.       (let ((map (make-sparse-keymap))
  659.         (dummy (make-sparse-keymap)))
  660.     ;; initialize all the vm-menu-fsfemacs-*-menu variables
  661.     ;; with the menus.
  662.     (vm-easy-menu-define vm-menu-fsfemacs-help-menu (list dummy) nil
  663.                  vm-menu-help-menu)
  664.     (vm-easy-menu-define vm-menu-fsfemacs-dispose-menu (list dummy) nil
  665.                  (cons "Dispose" (nthcdr 4 vm-menu-dispose-menu)))
  666.     (vm-easy-menu-define vm-menu-fsfemacs-dispose-popup-menu (list dummy) nil
  667.                  vm-menu-dispose-menu)
  668. ;;    (vm-easy-menu-define vm-menu-fsfemacs-undo-menu (list dummy) nil
  669. ;;                 (list "Undo" vm-menu-undo-menu))
  670.     (vm-easy-menu-define vm-menu-fsfemacs-virtual-menu (list dummy) nil
  671.                  vm-menu-virtual-menu)
  672.     (vm-easy-menu-define vm-menu-fsfemacs-sort-menu (list dummy) nil
  673.                  vm-menu-sort-menu)
  674.     (vm-easy-menu-define vm-menu-fsfemacs-label-menu (list dummy) nil
  675.                  vm-menu-label-menu)
  676.     (vm-easy-menu-define vm-menu-fsfemacs-mark-menu (list dummy) nil
  677.                  vm-menu-mark-menu)
  678.     (vm-easy-menu-define vm-menu-fsfemacs-send-menu (list dummy) nil
  679.                  vm-menu-send-menu)
  680.     (vm-easy-menu-define vm-menu-fsfemacs-motion-menu (list dummy) nil
  681.                  vm-menu-motion-menu)
  682. ;;    (vm-easy-menu-define vm-menu-fsfemacs-folders-menu (list dummy) nil
  683. ;;                 vm-menu-folders-menu)
  684.     (vm-easy-menu-define vm-menu-fsfemacs-folder-menu (list dummy) nil
  685.                  vm-menu-folder-menu)
  686.     (vm-easy-menu-define vm-menu-fsfemacs-vm-menu (list dummy) nil
  687.                  vm-menu-vm-menu)
  688.     ;; for mail mode
  689.     (vm-easy-menu-define vm-menu-fsfemacs-mail-menu (list dummy) nil
  690.                  vm-menu-mail-menu)
  691.     ;; subject menu
  692.     (vm-easy-menu-define vm-menu-fsfemacs-subject-menu (list dummy) nil
  693.                  vm-menu-subject-menu)
  694.     ;; author menu
  695.     (vm-easy-menu-define vm-menu-fsfemacs-author-menu (list dummy) nil
  696.                  vm-menu-author-menu)
  697.     ;; url browser menu
  698.     (vm-easy-menu-define vm-menu-fsfemacs-url-browser-menu (list dummy) nil
  699.                  vm-menu-url-browser-menu)
  700.     ;; mailto url browser menu
  701.     (vm-easy-menu-define vm-menu-fsfemacs-mailto-url-browser-menu
  702.                  (list dummy) nil
  703.                  vm-menu-url-browser-menu)
  704.     ;; mime dispose menu
  705.     (vm-easy-menu-define vm-menu-fsfemacs-mime-dispose-menu
  706.                  (list dummy) nil
  707.                  vm-menu-mime-dispose-menu)
  708.     ;; content disposition menu
  709.     (vm-easy-menu-define vm-menu-fsfemacs-content-disposition-menu
  710.                  (list dummy) nil
  711.                  vm-menu-content-disposition-menu)
  712.     ;; block the global menubar entries in the map so that VM
  713.     ;; can take over the menubar if necessary.
  714.     (define-key map [rootmenu] (make-sparse-keymap))
  715.     (define-key map [rootmenu vm] (cons "VM" (make-sparse-keymap "VM")))
  716.     (define-key map [rootmenu vm file] 'undefined)
  717.     (define-key map [rootmenu vm files] 'undefined)
  718.     (define-key map [rootmenu vm search] 'undefined)
  719.     (define-key map [rootmenu vm edit] 'undefined)
  720.     (define-key map [rootmenu vm options] 'undefined)
  721.     (define-key map [rootmenu vm buffer] 'undefined)
  722.     (define-key map [rootmenu vm tools] 'undefined)
  723.     (define-key map [rootmenu vm help] 'undefined)
  724.     ;; 19.29 changed the tag for the Help menu.
  725.     (define-key map [rootmenu vm help-menu] 'undefined)
  726.     ;; now build VM's menu tree.
  727.     (let ((menu-alist
  728.            '((dispose
  729.           (cons "Dispose" vm-menu-fsfemacs-dispose-menu))
  730.          (folder
  731.           (cons "Folder" vm-menu-fsfemacs-folder-menu))
  732.          (help
  733.           (cons "Help!" vm-menu-fsfemacs-help-menu))
  734.          (label
  735.           (cons "Label" vm-menu-fsfemacs-label-menu))
  736.          (mark
  737.           (cons "Mark" vm-menu-fsfemacs-mark-menu))
  738.          (motion
  739.           (cons "Motion" vm-menu-fsfemacs-motion-menu))
  740.          (send
  741.           (cons "Send" vm-menu-fsfemacs-send-menu))
  742.          (sort
  743.           (cons "Sort" vm-menu-fsfemacs-sort-menu))
  744.          (virtual
  745.           (cons "Virtual" vm-menu-fsfemacs-virtual-menu))
  746.          (emacs
  747.           (cons "[Emacs]" 'vm-menu-toggle-menubar))
  748.          (undo
  749.           (cons "[Undo]" 'vm-undo))))
  750.           cons
  751.           (vec (vector 'rootmenu 'vm nil))
  752.           ;; menus appear in the opposite order that we
  753.           ;; define-key them.
  754.           (menu-list 
  755.            (if (consp vm-use-menus)
  756.            (reverse vm-use-menus)
  757.          (list 'help nil 'dispose 'virtual 'sort
  758.                'label 'mark 'send 'motion 'folder))))
  759.       (while menu-list
  760.         (if (null (car menu-list))
  761.         nil;; no flushright support in FSF Emacs
  762.           (aset vec 2 (intern (concat "vm-menubar-"
  763.                       (symbol-name
  764.                        (car menu-list)))))
  765.           (setq cons (assq (car menu-list) menu-alist))
  766.           (if cons
  767.           (define-key map vec (eval (car (cdr cons))))))
  768.         (setq menu-list (cdr menu-list))))
  769.     (setq vm-mode-menu-map map)
  770.     (run-hooks 'vm-menu-setup-hook))))
  771.  
  772. (defun vm-menu-make-xemacs-menubar ()
  773.   (let ((menu-alist
  774.      '((dispose . vm-menu-dispose-menu)
  775.        (folder . vm-menu-folder-menu)
  776.        (help . vm-menu-help-menu)
  777.        (label . vm-menu-label-menu)
  778.        (mark . vm-menu-mark-menu)
  779.        (motion . vm-menu-motion-menu)
  780.        (send . vm-menu-send-menu)
  781.        (sort . vm-menu-sort-menu)
  782.        (virtual . vm-menu-virtual-menu)
  783.        (emacs . vm-menu-emacs-button)
  784.        (undo . vm-menu-undo-menu)))
  785.     cons
  786.     (menubar nil)
  787.     (menu-list vm-use-menus))
  788.     (while menu-list
  789.       (if (null (car menu-list))
  790.       (setq menubar (cons nil menubar))
  791.     (setq cons (assq (car menu-list) menu-alist))
  792.     (if cons
  793.         (setq menubar (cons (symbol-value (cdr cons)) menubar))))
  794.       (setq menu-list (cdr menu-list)))
  795.     (nreverse menubar) ))
  796.  
  797. (defun vm-menu-popup-mode-menu (event)
  798.   (interactive "e")
  799.   (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
  800.      (set-buffer (window-buffer (event-window event)))
  801.      (and (event-point event) (goto-char (event-point event)))
  802.      (popup-mode-menu))
  803.     ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
  804.      (set-buffer (window-buffer (posn-window (event-start event))))
  805.      (goto-char (posn-point (event-start event)))
  806.      (vm-menu-popup-fsfemacs-menu event))))
  807.  
  808. (defvar vm-menu-fsfemacs-content-disposition-menu)
  809. (defun vm-menu-popup-context-menu (event)
  810.   (interactive "e")
  811.   ;; We should not need to do anything here for XEmacs.  The
  812.   ;; default binding of mouse-3 is popup-mode-menu which does
  813.   ;; what we want for the normal case.  For special contexts,
  814.   ;; like when the mouse is over an URL, XEmacs has local keymap
  815.   ;; support for extents.  Any context sensitive area should be
  816.   ;; contained in an extent with a keymap that has mouse-3 bound
  817.   ;; to a function that will pop up a context sensitive menu.
  818.   (cond ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
  819.      (set-buffer (window-buffer (posn-window (event-start event))))
  820.      (goto-char (posn-point (event-start event)))
  821.      (if (get-text-property (point) 'vm-mime-object)
  822.          (vm-menu-popup-fsfemacs-menu
  823.           event vm-menu-fsfemacs-content-disposition-menu)
  824.        (let (o-list o menu (found nil))
  825.          (setq o-list (overlays-at (point)))
  826.          (while (and o-list (not found))
  827.            (cond ((overlay-get (car o-list) 'vm-url)
  828.               (setq found t)
  829.               (vm-menu-popup-url-browser-menu event))
  830.              ((setq menu (overlay-get (car o-list) 'vm-header))
  831.               (setq found t)
  832.               (vm-menu-popup-fsfemacs-menu event menu))
  833.              ((overlay-get (car o-list) 'vm-mime-layout)
  834.               (setq found t)
  835.               (vm-menu-popup-mime-dispose-menu event)))
  836.            (setq o-list (cdr o-list)))
  837.          (and (not found) (vm-menu-popup-fsfemacs-menu event)))))))
  838.  
  839. ;; to quiet the byte-compiler
  840. (defvar vm-menu-fsfemacs-url-browser-menu)
  841. (defvar vm-menu-fsfemacs-mailto-url-browser-menu)
  842. (defvar vm-menu-fsfemacs-mime-dispose-menu)
  843.  
  844. (defun vm-menu-goto-event (event)
  845.   (cond ((vm-menu-xemacs-menus-p)
  846.      ;; Must select window instead of just set-buffer because
  847.      ;; popup-menu returns before the user has made a
  848.      ;; selection.  This will cause the command loop to
  849.      ;; resume which might undo what set-buffer does.
  850.      (select-window (event-window event))
  851.      (and (event-closest-point event)
  852.           (goto-char (event-closest-point event))))
  853.     ((vm-menu-fsfemacs-menus-p)
  854.      (set-buffer (window-buffer (posn-window (event-start event))))
  855.      (goto-char (posn-point (event-start event))))))
  856.  
  857. (defun vm-menu-popup-url-browser-menu (event)
  858.   (interactive "e")
  859.   (vm-menu-goto-event event)
  860.   (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
  861.      (popup-menu vm-menu-url-browser-menu))
  862.     ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
  863.      (vm-menu-popup-fsfemacs-menu
  864.       event vm-menu-fsfemacs-url-browser-menu))))
  865.  
  866. (defun vm-menu-popup-mailto-url-browser-menu (event)
  867.   (interactive "e")
  868.   (vm-menu-goto-event event)
  869.   (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
  870.      (popup-menu vm-menu-mailto-url-browser-menu))
  871.     ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
  872.      (vm-menu-popup-fsfemacs-menu
  873.       event vm-menu-fsfemacs-mailto-url-browser-menu))))
  874.  
  875. (defun vm-menu-popup-mime-dispose-menu (event)
  876.   (interactive "e")
  877.   (vm-menu-goto-event event)
  878.   (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
  879.      (popup-menu vm-menu-mime-dispose-menu))
  880.     ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
  881.      (vm-menu-popup-fsfemacs-menu
  882.       event vm-menu-fsfemacs-mime-dispose-menu))))
  883.  
  884. (defun vm-menu-popup-content-disposition-menu (event)
  885.   (interactive "e")
  886.   (vm-menu-goto-event event)
  887.   (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
  888.      (popup-menu vm-menu-content-disposition-menu))
  889.     ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
  890.      (vm-menu-popup-fsfemacs-menu
  891.       event vm-menu-fsfemacs-content-disposition-menu))))
  892.  
  893. ;; to quiet the byte-compiler
  894. (defvar vm-menu-fsfemacs-mail-menu)
  895. (defvar vm-menu-fsfemacs-dispose-popup-menu)
  896. (defvar vm-menu-fsfemacs-vm-menu)
  897.  
  898. (defun vm-menu-popup-fsfemacs-menu (event &optional menu)
  899.   (interactive "e")
  900.   (set-buffer (window-buffer (posn-window (event-start event))))
  901.   (goto-char (posn-point (event-start event)))
  902.   (let ((map (or menu mode-popup-menu))
  903.     key command func)
  904.     (setq key (x-popup-menu event map)
  905.       key (apply 'vector key)
  906.           command (lookup-key map key)
  907.       func (and (symbolp command) (symbol-function command)))
  908.     (cond ((null func) (setq this-command last-command))
  909.       ((symbolp func)
  910.        (setq this-command func)
  911.        (call-interactively this-command))
  912.       (t
  913.        (call-interactively command)))))
  914.  
  915. (defun vm-menu-mode-menu ()
  916.   (if (vm-menu-xemacs-menus-p)
  917.       (cond ((eq major-mode 'mail-mode)
  918.          vm-menu-mail-menu)
  919.         ((memq major-mode '(vm-mode vm-presentation-mode
  920.                 vm-summary-mode vm-virtual-mode))
  921.          vm-menu-dispose-menu)
  922.         (t vm-menu-vm-menu))
  923.     (cond ((eq major-mode 'mail-mode)
  924.        vm-menu-fsfemacs-mail-menu)
  925.       ((memq major-mode '(vm-mode vm-summary-mode vm-virtual-mode))
  926.        vm-menu-fsfemacs-dispose-popup-menu)
  927.       (t vm-menu-fsfemacs-vm-menu))))
  928.  
  929. (defun vm-menu-set-menubar-dirty-flag ()
  930.   (cond ((vm-menu-xemacs-menus-p)
  931.      (set-menubar-dirty-flag))
  932.     ((vm-menu-fsfemacs-menus-p)
  933.      (force-mode-line-update))))
  934.  
  935. (defun vm-menu-toggle-menubar (&optional buffer)
  936.   (interactive)
  937.   (if buffer
  938.       (set-buffer buffer)
  939.     (vm-select-folder-buffer))
  940.   (cond ((vm-menu-xemacs-menus-p)
  941.      (if (null (car (find-menu-item current-menubar '("XEmacs"))))
  942.          (set-buffer-menubar vm-menu-vm-menubar)
  943.        ;; copy the current menubar in case it has been changed.
  944.        (make-local-variable 'vm-menu-vm-menubar)
  945.        (setq vm-menu-vm-menubar (copy-sequence current-menubar))
  946.        (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar)))
  947.        (condition-case nil
  948.            (add-menu-button nil vm-menu-vm-button nil)
  949.          (void-function
  950.           (add-menu-item nil "VM" 'vm-menu-toggle-menubar t))))
  951.      (vm-menu-set-menubar-dirty-flag)
  952.      (vm-check-for-killed-summary)
  953.      (and vm-summary-buffer
  954.           (save-excursion
  955.         (vm-menu-toggle-menubar vm-summary-buffer)))
  956.      (vm-check-for-killed-presentation)
  957.      (and vm-presentation-buffer-handle
  958.           (save-excursion
  959.         (vm-menu-toggle-menubar vm-presentation-buffer-handle))))
  960.     ((vm-menu-fsfemacs-menus-p)
  961.      (if (not (eq (lookup-key vm-mode-map [menu-bar])
  962.               (lookup-key vm-mode-menu-map [rootmenu vm])))
  963.          (define-key vm-mode-map [menu-bar]
  964.            (lookup-key vm-mode-menu-map [rootmenu vm]))
  965.        (define-key vm-mode-map [menu-bar]
  966.          (make-sparse-keymap))
  967.        (define-key vm-mode-map [menu-bar vm]
  968.          (cons "[VM]" 'vm-menu-toggle-menubar)))
  969.      (vm-menu-set-menubar-dirty-flag))))
  970.  
  971. (defun vm-menu-install-menubar ()
  972.   (cond ((vm-menu-xemacs-menus-p)
  973.      (setq vm-menu-vm-menubar (vm-menu-make-xemacs-menubar))
  974.      (set-buffer-menubar vm-menu-vm-menubar)
  975.          (run-hooks 'vm-menu-setup-hook)
  976.          (setq vm-menu-vm-menubar current-menubar))
  977.     ((and (vm-menu-fsfemacs-menus-p)
  978.           ;; menus only need to be installed once for FSF Emacs
  979.           (not (fboundp 'vm-menu-undo-menu)))
  980.      (vm-menu-initialize-vm-mode-menu-map)
  981.      (define-key vm-mode-map [menu-bar]
  982.        (lookup-key vm-mode-menu-map [rootmenu vm])))))
  983.  
  984. (defun vm-menu-install-menubar-item ()
  985.   (cond ((and (vm-menu-xemacs-menus-p) (vm-menu-xemacs-global-menubar))
  986.      (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar)))
  987.      (add-menu nil "VM" (cdr vm-menu-vm-menu)))
  988.     ((and (vm-menu-fsfemacs-menus-p)
  989.           ;; menus only need to be installed once for FSF Emacs
  990.           (not (fboundp 'vm-menu-undo-menu)))
  991.      (vm-menu-initialize-vm-mode-menu-map)
  992.      (define-key vm-mode-map [menu-bar]
  993.        (lookup-key vm-mode-menu-map [rootmenu])))))
  994.  
  995. (defun vm-menu-install-vm-mode-menu ()
  996.   ;; nothing to do here.
  997.   ;; handled in vm-mouse.el
  998.   (cond ((vm-menu-xemacs-menus-p)
  999.      t )
  1000.     ((vm-menu-fsfemacs-menus-p)
  1001.      t )))
  1002.  
  1003. (defun vm-menu-install-mail-mode-menu ()
  1004.   (cond ((vm-menu-xemacs-menus-p)
  1005.      ;; mail-mode doesn't have mode-popup-menu bound to
  1006.      ;; mouse-3 by default.  fix that.
  1007.      (if vm-popup-menu-on-mouse-3
  1008.          (define-key vm-mail-mode-map 'button3 'popup-mode-menu))
  1009.      ;; put menu on menubar also.
  1010.      (if (vm-menu-xemacs-global-menubar)
  1011.          (progn
  1012.            (set-buffer-menubar
  1013.         (copy-sequence (vm-menu-xemacs-global-menubar)))
  1014.            (add-menu nil "Mail" (cdr vm-menu-mail-menu))))
  1015.      t )
  1016.     ((vm-menu-fsfemacs-menus-p)
  1017.      ;; I'd like to do this, but the result is a combination
  1018.      ;; of the Emacs and VM Mail menus glued together.
  1019.      ;; Poorly.
  1020.      ;;(define-key vm-mail-mode-map [menu-bar mail]
  1021.      ;;  (cons "Mail" vm-menu-fsfemacs-mail-menu))
  1022.      (defvar mail-mode-map)
  1023.      (define-key mail-mode-map [menu-bar mail]
  1024.        (cons "Mail" vm-menu-fsfemacs-mail-menu))
  1025.      (if vm-popup-menu-on-mouse-3
  1026.          (define-key vm-mail-mode-map [down-mouse-3]
  1027.            'vm-menu-popup-context-menu)))))
  1028.  
  1029. (defun vm-menu-install-menus ()
  1030.   (cond ((consp vm-use-menus)
  1031.      (vm-menu-install-vm-mode-menu)
  1032.      (vm-menu-install-menubar)
  1033.      (vm-menu-install-known-virtual-folders-menu))
  1034.     ((eq vm-use-menus 1)
  1035.      (vm-menu-install-vm-mode-menu)
  1036.      (vm-menu-install-menubar-item)
  1037.      (vm-menu-install-known-virtual-folders-menu))
  1038.     (t nil)))
  1039.  
  1040. (defun vm-menu-install-known-virtual-folders-menu ()
  1041.   (let ((folders (sort (mapcar 'car vm-virtual-folder-alist)
  1042.                (function string-lessp)))
  1043.     (menu nil)
  1044.     tail
  1045.     ;; special string indicating tail of Virtual menu
  1046.     (special "-------"))
  1047.     (while folders
  1048.       (setq menu (cons (vector "    "
  1049.                    (list 'vm-menu-run-command
  1050.                      ''vm-visit-virtual-folder (car folders))
  1051.                    t
  1052.                    (car folders))
  1053.                menu)
  1054.         folders (cdr folders)))
  1055.     (and menu (setq menu (nreverse menu)
  1056.             menu (nconc (list "Visit:" "---") menu)))
  1057.     (setq tail (vm-member special vm-menu-virtual-menu))
  1058.     (if (and menu tail)
  1059.     (progn
  1060.       (setcdr tail menu)
  1061.       (vm-menu-set-menubar-dirty-flag)
  1062.       (cond ((vm-menu-fsfemacs-menus-p)
  1063.          (makunbound 'vm-menu-fsfemacs-virtual-menu)
  1064.          (vm-easy-menu-define vm-menu-fsfemacs-virtual-menu
  1065.                       (list (make-sparse-keymap))
  1066.                       nil
  1067.                       vm-menu-virtual-menu)
  1068.          (define-key vm-mode-menu-map [rootmenu vm vm-menubar-virtual]
  1069.            (cons "Virtual" vm-menu-fsfemacs-virtual-menu))))))))
  1070.  
  1071. (defun vm-menu-install-visited-folders-menu ()
  1072.   (let ((folders (vm-delete-duplicates (copy-sequence vm-folder-history)))
  1073.     (menu nil)
  1074.     tail
  1075.     spool-files
  1076.     (i 0)
  1077.     ;; special string indicating tail of Folder menu
  1078.     (special "-------"))
  1079.     (while (and folders (< i 10))
  1080.       (setq menu (cons (vector "    "
  1081.                    (list 'vm-menu-run-command
  1082.                      ''vm-visit-folder (car folders))
  1083.                    t
  1084.                    (car folders))
  1085.                menu)
  1086.         folders (cdr folders)
  1087.         i (1+ i)))
  1088.     (and menu (setq menu (nreverse menu)
  1089.             menu (nconc (list "Visit:" "---") menu)))
  1090.     (setq spool-files (vm-spool-files)
  1091.       folders (cond ((and (consp spool-files)
  1092.                   (consp (car spool-files)))
  1093.              (mapcar (function car) spool-files))
  1094.             ((and (consp spool-files)
  1095.                   (stringp (car spool-files))
  1096.                   (stringp vm-primary-inbox))
  1097.              (list vm-primary-inbox))
  1098.             (t nil)))
  1099.     (if (and menu folders)
  1100.     (nconc menu (list "---" "---")))
  1101.     (while folders
  1102.       (setq menu (nconc menu
  1103.             (list (vector "    "
  1104.                       (list 'vm-menu-run-command
  1105.                         ''vm-visit-folder (car folders))
  1106.                       t
  1107.                       (car folders))))
  1108.         folders (cdr folders)))
  1109.     (setq tail (vm-member special vm-menu-folder-menu))
  1110.     (if (and menu tail)
  1111.     (progn
  1112.       (setcdr tail menu)
  1113.       (vm-menu-set-menubar-dirty-flag)
  1114.       (cond ((vm-menu-fsfemacs-menus-p)
  1115.          (makunbound 'vm-menu-fsfemacs-folder-menu)
  1116.          (vm-easy-menu-define vm-menu-fsfemacs-folder-menu
  1117.                       (list (make-sparse-keymap))
  1118.                       nil
  1119.                       vm-menu-folder-menu)
  1120.          (define-key vm-mode-menu-map [rootmenu vm vm-menubar-folder]
  1121.            (cons "Folder" vm-menu-fsfemacs-folder-menu))))))))
  1122.  
  1123.  
  1124. ;;; Muenkel Folders menu code
  1125.  
  1126. (defvar vm-menu-hm-no-hidden-dirs t
  1127.   "*Hidden directories are suppressed in the folder menus, if non nil.")
  1128.  
  1129. (defvar vm-menu-hm-hidden-file-list '("^\\..*" ".*\\.~[0-9]+~"))
  1130.  
  1131. (defun vm-menu-hm-delete-folder (folder)
  1132.   "Query deletes a folder."
  1133.   (interactive "fDelete folder: ")
  1134.   (if (file-exists-p folder)
  1135.       (if (y-or-n-p (concat "Delete the folder " folder " ? "))
  1136.       (progn
  1137.         (if (file-directory-p folder)
  1138.         (delete-directory folder)
  1139.           (delete-file folder))
  1140.         (message "Folder deleted.")
  1141.         (vm-menu-hm-make-folder-menu)
  1142.         (vm-menu-hm-install-menu)
  1143.         )
  1144.     (message "Aborted"))
  1145.     (error "Folder %s does not exist." folder)
  1146.     (vm-menu-hm-make-folder-menu)
  1147.     (vm-menu-hm-install-menu)
  1148.     ))
  1149.     
  1150.  
  1151. (defun vm-menu-hm-rename-folder (folder)
  1152.   "Rename a folder."
  1153.   (interactive "fRename folder: ")
  1154.   (if (file-exists-p folder)
  1155.       (rename-file folder
  1156.            (read-file-name (concat "Rename "
  1157.                        folder
  1158.                        " to ")
  1159.                    (directory-file-name folder)
  1160.                    folder))
  1161.     (error "Folder %s does not exist." folder))
  1162.   (vm-menu-hm-make-folder-menu)
  1163.   (vm-menu-hm-install-menu)
  1164.   )
  1165.  
  1166.  
  1167. (defun vm-menu-hm-create-dir (parent-dir)
  1168.   "Create a subdir in PARENT-DIR."
  1169.   (interactive "DCreate new directory in: ")
  1170.   (setq parent-dir (or parent-dir vm-folder-directory))
  1171.   (make-directory 
  1172.    (expand-file-name (read-file-name
  1173.               (format "Create directory in %s called: "
  1174.                   parent-dir)
  1175.               parent-dir)
  1176.              vm-folder-directory)
  1177.    t)
  1178.   (vm-menu-hm-make-folder-menu)
  1179.   (vm-menu-hm-install-menu)
  1180.   )
  1181.  
  1182.  
  1183. (defun vm-menu-hm-make-folder-menu ()
  1184.   "Makes a menu with the mail folders of the directory `vm-folder-directory'."
  1185.   (interactive)
  1186.   (message "Building folders menu...")
  1187.   (let ((folder-list (vm-menu-hm-tree-make-file-list vm-folder-directory))
  1188.     (inbox-list (if (listp (car vm-spool-files))
  1189.             (mapcar 'car vm-spool-files)
  1190.               (list vm-primary-inbox))))
  1191.     (setq vm-menu-folders-menu
  1192.       (cons "Manipulate Folders"
  1193.         (list (cons "Visit Inboxes  "
  1194.                 (vm-menu-hm-tree-make-menu 
  1195.                  inbox-list
  1196.                  'vm-visit-folder
  1197.                  t))
  1198.               (cons "Visit Folder   "
  1199.                 (vm-menu-hm-tree-make-menu 
  1200.                  folder-list
  1201.                  'vm-visit-folder
  1202.                  t
  1203.                  vm-menu-hm-no-hidden-dirs
  1204.                  vm-menu-hm-hidden-file-list))
  1205.               (cons "Save Message   "
  1206.                 (vm-menu-hm-tree-make-menu 
  1207.                  folder-list
  1208.                  'vm-save-message
  1209.                  t
  1210.                  vm-menu-hm-no-hidden-dirs
  1211.                  vm-menu-hm-hidden-file-list))
  1212.               "----"
  1213.               (cons "Delete Folder  "
  1214.                 (vm-menu-hm-tree-make-menu 
  1215.                  folder-list
  1216.                  'vm-menu-hm-delete-folder
  1217.                  t
  1218.                  nil
  1219.                  nil
  1220.                  t
  1221.                  ))
  1222.               (cons "Rename Folder  "
  1223.                 (vm-menu-hm-tree-make-menu 
  1224.                  folder-list
  1225.                  'vm-menu-hm-rename-folder
  1226.                  t
  1227.                  nil
  1228.                  nil
  1229.                  t
  1230.                  ))
  1231.               (cons "Make New Directory in..."
  1232.                 (vm-menu-hm-tree-make-menu 
  1233.                  (cons (list vm-folder-directory) folder-list)
  1234.                  'vm-menu-hm-create-dir
  1235.                  t
  1236.                  nil
  1237.                  '(".*")
  1238.                  t
  1239.                  ))
  1240.               "----"
  1241.               ["Rebuild Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory]
  1242.               ))))
  1243.   (message "Building folders menu... done")
  1244.   (vm-menu-hm-install-menu))
  1245.  
  1246. (defun vm-menu-hm-install-menu ()
  1247.   (cond ((vm-menu-xemacs-menus-p)
  1248.      (cond ((car (find-menu-item current-menubar '("VM")))
  1249.         (add-menu '("VM") "Folders"
  1250.               (cdr vm-menu-folders-menu) "Motion"))
  1251.            ((car (find-menu-item current-menubar
  1252.                      '("Folder" "Manipulate Folders")))
  1253.         (add-menu '("Folder") "Manipulate Folders"
  1254.               (cdr vm-menu-folders-menu) "Motion"))))
  1255.     ((vm-menu-fsfemacs-menus-p)
  1256.      (vm-easy-menu-define vm-menu-fsfemacs-folders-menu
  1257.                   (list (make-sparse-keymap))
  1258.                   nil
  1259.                   vm-menu-folders-menu)
  1260.      (define-key vm-mode-menu-map [rootmenu vm folder folders]
  1261.        (cons "Manipulate Folders" vm-menu-fsfemacs-folders-menu)))))
  1262.  
  1263.  
  1264. ;;; Muenkel tree-menu code
  1265.  
  1266. (defvar vm-menu-hm-tree-ls-flags "-aFLR" 
  1267.   "*A String with the flags used in the function
  1268. vm-menu-hm-tree-ls-in-temp-buffer for the ls command.
  1269. Be careful if you want to change this variable. 
  1270. The ls command must append a / on all files which are directories. 
  1271. The original flags are -aFLR.")
  1272.  
  1273.  
  1274. (defun vm-menu-hm-tree-ls-in-temp-buffer (dir temp-buffer)
  1275. "List the directory DIR in the TEMP-BUFFER."
  1276.   (switch-to-buffer temp-buffer)
  1277.   (erase-buffer)
  1278.   (let ((process-connection-type nil))
  1279.     (call-process "ls" nil temp-buffer nil vm-menu-hm-tree-ls-flags dir))
  1280.   (goto-char (point-min))
  1281.   (while (search-forward "//" nil t)
  1282.     (replace-match "/"))
  1283.   (goto-char (point-min))
  1284.   (while (re-search-forward "\\.\\.?/\n" nil t)
  1285.     (replace-match ""))
  1286.   (goto-char (point-min)))
  1287.  
  1288.  
  1289. (defvar vm-menu-hm-tree-temp-buffername "*tree*"
  1290.   "Name of the temp buffers in tree.")
  1291.  
  1292.  
  1293. (defun vm-menu-hm-tree-make-file-list-1 (root list)
  1294.   (let ((filename (buffer-substring (point) (progn
  1295.                           (end-of-line)
  1296.                           (point)))))
  1297.     (while (not (string= filename ""))
  1298.       (setq 
  1299.        list 
  1300.        (append
  1301.     list
  1302.     (list
  1303.      (cond ((char-equal (char-after (- (point) 1)) ?/)
  1304.         ;; Directory
  1305.         (setq filename (substring filename 0 (1- (length filename))))
  1306.         (save-excursion
  1307.           (search-forward (concat root filename ":"))
  1308.           (forward-line)
  1309.           (vm-menu-hm-tree-make-file-list-1 (concat root filename "/")
  1310.                         (list (vm-menu-hm-tree-menu-file-truename 
  1311.                                filename
  1312.                                root)))))
  1313.            ((char-equal (char-after (- (point) 1)) ?*)
  1314.         ;; Executable
  1315.         (setq filename (substring filename 0 (1- (length filename))))
  1316.         (vm-menu-hm-tree-menu-file-truename filename root))
  1317.            (t (vm-menu-hm-tree-menu-file-truename filename root))))))
  1318.       (forward-line)
  1319.       (setq filename (buffer-substring (point) (progn
  1320.                          (end-of-line)
  1321.                          (point)))))
  1322.     list))
  1323.  
  1324.  
  1325. (defun vm-menu-hm-tree-menu-file-truename (file &optional root)
  1326.   (file-truename (expand-file-name file root)))
  1327.  
  1328. (defun vm-menu-hm-tree-make-file-list (dir)
  1329.   "Makes a list with the files and subdirectories of DIR.
  1330. The list looks like: ((dirname1 file1 file2) 
  1331.                       file3
  1332.                       (dirname2 (dirname3 file4 file5) file6))"
  1333.   (save-window-excursion
  1334.     (setq dir (expand-file-name dir))
  1335.     (if (not (string= (substring dir -1) "/"))
  1336.     (setq dir (concat dir "/")))
  1337. ;;    (while (string-match "/$" dir)
  1338. ;;      (setq dir (substring dir 0 -1)))
  1339.     (vm-menu-hm-tree-ls-in-temp-buffer dir
  1340.                  (generate-new-buffer-name 
  1341.                   vm-menu-hm-tree-temp-buffername))
  1342.     (let ((list nil))
  1343.       (setq list (vm-menu-hm-tree-make-file-list-1 dir nil))
  1344.       (kill-buffer (current-buffer))
  1345.       list)))
  1346.  
  1347.  
  1348. (defun vm-menu-hm-tree-hide-file-p (filename re-hidden-file-list)
  1349.   "t, if one of the regexps in RE-HIDDEN-FILE-LIST matches the FILENAME."
  1350.   (cond ((not re-hidden-file-list) nil)
  1351.     ((string-match (car re-hidden-file-list) 
  1352.                (vm-menu-hm-tree-menu-file-truename filename)))
  1353.     (t (vm-menu-hm-tree-hide-file-p filename (cdr re-hidden-file-list)))))
  1354.  
  1355.  
  1356. (defun vm-menu-hm-tree-make-menu (dirlist 
  1357.                function 
  1358.                selectable 
  1359.                &optional 
  1360.                no-hidden-dirs
  1361.                re-hidden-file-list
  1362.                include-current-dir)
  1363.   "Returns a menu list.
  1364. Each item of the menu list has the form 
  1365.  [\"subdir\" (FUNCTION \"dir\") SELECTABLE].
  1366. Hidden directories (with a leading point) are suppressed, 
  1367. if NO-HIDDEN-DIRS are non nil. Also all files which are
  1368. matching a regexp in RE-HIDDEN-FILE-LIST are suppressed.
  1369. If INCLUDE-CURRENT-DIR non nil, then an additional command
  1370. for the current directory (.) is inserted."
  1371.   (let ((subdir nil)
  1372.     (menulist nil))
  1373.     (while (setq subdir (car dirlist))
  1374.       (setq dirlist (cdr dirlist))
  1375.       (cond ((and (stringp subdir)
  1376.           (not (vm-menu-hm-tree-hide-file-p subdir re-hidden-file-list)))
  1377.          (setq menulist
  1378.            (append menulist
  1379.                (list
  1380.                 (vector (file-name-nondirectory subdir)
  1381.                     (list function subdir)
  1382.                     selectable)))))
  1383.         ((and (listp subdir)
  1384.           (or (not no-hidden-dirs)
  1385.               (not (char-equal 
  1386.                 ?.
  1387.                 (string-to-char 
  1388.                  (file-name-nondirectory (car subdir))))))
  1389.           (setq menulist
  1390.             (append 
  1391.              menulist
  1392.              (list
  1393.               (cons (file-name-nondirectory (car subdir))
  1394.                 (if include-current-dir
  1395.                     (cons
  1396.                      (vector "."
  1397.                          (list function
  1398.                            (car subdir))
  1399.                          selectable)
  1400.                      (vm-menu-hm-tree-make-menu (cdr subdir)
  1401.                              function
  1402.                              selectable
  1403.                              no-hidden-dirs
  1404.                              re-hidden-file-list
  1405.                              include-current-dir
  1406.                              ))
  1407.                   (vm-menu-hm-tree-make-menu (cdr subdir)
  1408.                           function
  1409.                           selectable
  1410.                           no-hidden-dirs
  1411.                           re-hidden-file-list
  1412.                           ))))))))
  1413.         (t nil))
  1414.       )
  1415.     menulist
  1416.     )
  1417.   )
  1418.